home *** CD-ROM | disk | FTP | other *** search
/ Scene 96 / Scene 96 International Edition (Zyklop Software) (Disc 2) (1997).iso / misc / utilz / tk_dbbd / db-bd01.pas next >
Pascal/Delphi Source File  |  1996-07-29  |  11KB  |  269 lines
  1. PROGRAM BinaeRDezimaLundDezimaLBinaeRUmwandeln;                 {File db-bd01.pas}
  2.  
  3. { Autor: Terror Kid     }
  4. { Datum: April/Mai 1996 }
  5. { Filename: db-bd01.pas }
  6.  
  7. { Kurzbeschrieb: Das Programm hat die Aufgabe, Binäre- in Dezimale Zahlen   }
  8. { und Dezimale- in Binäre Zahlenumzuwandeln. Die höchste dezimale Zahl darf }
  9. { 255 sein, die binäre Zahl muss 8-stellig eingegeben werden.               }
  10.  
  11. USES crt;                                                       {Hardware initialisieren}
  12. VAR Wahl                                                        : Integer;     {div. Variablen definieren}
  13. VAR DezBin01, DezBinUmw1, BinDezUmw1                            : Real;
  14. VAR RAM01, RAM02, RAM03, RAM04, RAM05, RAM06                    : Real;
  15. VAR RAM07, RAM08, RAM09, RAM10, RAM11, Durchlauf                : Real;
  16. VAR BinDez01, BinDez02, BinDez03, BinDez04                      : Real;
  17. VAR BinDez05, BinDez06, BinDez07, BinDez08                      : Real;
  18. VAR Frage, Abfrage, Fehler                                      : Char;
  19.  
  20. {    ACHTUNG ! Nun kommt ein kleiner grafischer Effekt, der "Real-time      }
  21. {    color-mix-copper (5)" von Bas van Gaalen, Holland, als PD freigegeben  }
  22. {---------------------------------------------------------------------------}
  23. const size=350; step=250; bars=3;
  24. var
  25.   pal:array[0..3*size-1] of byte;
  26.   stab:array[0..255] of word;
  27.   bartab:array[0..bars-1] of word;
  28.  
  29. procedure createtab; var i:byte; begin
  30. for i:=0 to 255 do stab[i]:=round(sin(2*pi*i/255)*105)+112; end;
  31. procedure movebars;
  32. var n,i:word;
  33. begin;
  34.   normvideo;
  35.   fillchar(pal[6],3*size-13,0);
  36.   for n:=0 to bars-1 do begin
  37.     for i:=0 to 63 do pal[n mod 3+3*stab[bartab[n]]+3*i]:=i;
  38.     for i:=0 to 63 do pal[n mod 3+3*stab[bartab[n]]+3*64+3*i]:=63-i;
  39.     bartab[n]:=1+bartab[n] mod 255;
  40.   end;
  41. end;
  42.  
  43. procedure copperbars;
  44. var cc,l:word;
  45. begin
  46.   asm cli end;
  47.   while (port[$3da] and 8) <> 0 do;
  48.   while (port[$3da] and 8) = 0 do;
  49.   cc:=0;
  50.   for l:=0 to size-1 do begin
  51.     port[$3c8]:=0;
  52.     port[$3c9]:=pal[cc];
  53.     port[$3c9]:=pal[cc+1];
  54.     while (port[$3da] and 1) <> 0 do;
  55.     while (port[$3da] and 1) = 0 do;
  56.     port[$3c9]:=pal[cc+2];
  57.     inc(cc,3);
  58.   end;
  59.   asm sti end;
  60. end;
  61.  
  62. var i:byte;
  63. begin
  64.   fillchar(pal,sizeof(pal),0);
  65.   for i:=0 to bars-1 do bartab[i]:=step*i;
  66.   pal[3*size-6]:=50; pal[3*size-5]:=50; pal[3*size-4]:=50;
  67.   pal[3]:=50; pal[4]:=50; pal[5]:=50;
  68. {---------------------------------------------------------------------------}
  69.  
  70. Clrscr;
  71. Normvideo;                                                      {Benutzt wieder die Textfarbe wie am Anfang des Programms}
  72. Clrscr;
  73. Writeln;
  74. Writeln ('    ██▀▀▀▄     ██▀▀▀▀▀    ███████     ▀██▀    ▄█▀██▀█▄    ██▀▀▀██    ██      ');
  75. Writeln ('  █ ██ █ ██ ██ ██ █████ █▄▄▄▄▄ ██ █ ██ ██ ███ ██ ██ ██ ██ ██ █ ██ ██ ██ █████');
  76. Writeln ('  █ ██ █ ██ ██ ██ █████ ██████ ██ █ ██ ██ ███ ██ ██ ██ ██ ██ ▀ ██ ██ ██ █████');
  77. Writeln ('  █ ██ █ ██ ██ ██▄▄▄ ██ ████▀▀ ██ █ ██ ██ ███ ██ ██ ██ ██ ███████ ██ ██ █████');
  78. Writeln ('  █ ██ █ ██ ██ ██ ▄▄▄██ ██▀▀ ██ ▄▄█ ██ ██ ███ ██ ██ ██ ██ ██ ▄ ██ ██ ██ █████');
  79. Writeln ('  █ ██ █ ██ ██ ██ █████ █▀ ██ ▄▄███ ██ ██ ███ ██ ██ ██ ██ ██ █ ██ ██ ██ █████');
  80. Writeln ('  █ ██ █ ██ ██ ██ █████ █ ██ ▄█████ ██ ██ ███ ██ ██ ██ ██ ██ █ ██ ██ ██ █████');
  81. Writeln ('  █ ██ █ ██ ██ ██ █████ █ ██ ▀▀▀▀▀█ ██ ██ ███ ██ ██ ██ ██ ██ █ ██ ██ ██ █████');
  82. Writeln ('  ▀ ██▄▄▄▀  ▀▀ ██▄▄▄▄▄  ▀ ███████ ▀ ▀ ▄██▄ ▀▀ ██ ██ ██ ▀▀ ██ ▀ ██ ▀▀ ██▄▄▄▄ ▀');
  83. Writeln ('                                                                  ');
  84. Textcolor (19);                                                 {Setzt eine Farbe für Textausgabe}
  85. Writeln ('                                              .oO Oo.              ');
  86. Normvideo;                                                      {Setzt Farbatributt zurück wie bei Programmbeginn}
  87. Writeln ('                ██▀▀▀█▄    ▀██▀    ██▀▀▀▄▄    ██▀▀▀██    ██▀▀▀██  ');
  88. Writeln ('              █ ██ █ ██ ███ ██ ███ ██ █ ██ ██ ██ █ ██ ██ ██ █ ██ █');
  89. Writeln ('              █ ██ ▀ ██ ███ ██ ███ ██ █ ██ ██ ██ ▀ ██ ██ ██ █ ██ █');
  90. Writeln ('              █ ██████▀ ███ ██ ███ ██ █ ██ ██ ███████ ██ ██ ▀ ██ █');
  91. Writeln ('              █ ██ ▄ ██ ███ ██ ███ ██ █ ██ ██ ██ ▄ ██ ██ ██████  █');
  92. Writeln ('              █ ██ █ ██ ███ ██ ███ ██ █ ██ ██ ██ █ ██ ██ ██ ▄ ██ █');
  93. Writeln ('              █ ██ █ ██ ███ ██ ███ ██ █ ██ ██ ██ █ ██ ██ ██ █ ██ █');
  94. Writeln ('              █ ██ █ ██ ███ ██ ███ ██ █ ██ ██ ██ █ ██ ██ ██ █ ██ █');
  95. Writeln ('              ▀ ██▄▄▄█▀ ▀▀ ▄██▄ ▀▀ ██ ▀ ██ ▀▀ ██ ▀ ██ ▀▀ ██ ▀ ██ ▀');
  96. Writeln ('');
  97. Textcolor (19);                                                 {Setzt eine Farbe für Textausgabe}
  98. Writeln ('');
  99. Writeln ('                    und zurück...  U-M-W-A-N-D-E-L-N   !-!-!');
  100. Normvideo;                                                      
  101.   createtab;
  102.   repeat
  103.   movebars;
  104.   copperbars;
  105. until keypressed;                                               {Routine so lange ausführen bis eine Taste gedrückt wird}
  106. Clrscr;
  107. REPEAT
  108. Clrscr;
  109.      Writeln;                                                   {Leerzeile schreiben}
  110.      Writeln ('Welche Umwandlung wollen Sie treffen ?');
  111.      Writeln;
  112.      Writeln (' 1 = Dezimal-Binär Umwandlung');
  113.      Writeln (' 2 = Binär-Dezimal Umwandlung');
  114.      Writeln;
  115.      Write ('  ');
  116.      Readln (Wahl);
  117.  
  118.      CASE Wahl of
  119.  
  120.     1 : BEGIN
  121.  
  122.         REPEAT
  123.                 DezBin01:=0;
  124.                 Writeln;
  125.         Write ('Sie haben die Umwandlung "Dezimal-Binär"');
  126.         Writeln (' gewählt.');
  127.                 Writeln;
  128.                 Write ('Dezimale Zahl eingeben: ');
  129.                 Readln (DezBin01);
  130.                 Writeln;
  131.                 IF DezBin01 > 255 then Writeln ('Dezimale Zahl max. 255, Resultat ungültig, nochmals ausrechnen !!!');
  132.                 Writeln;
  133.                        Durchlauf:= 1;
  134.                        REPEAT
  135.                        DezBinUmw1:=DezBin01 / 2;
  136.                        RAM01:=Trunc (DezBinUmw1);
  137.                        RAM02:=DezBinUmw1 - RAM01;
  138.                        IF RAM02=0.5 then RAM03:=1;
  139.                        IF RAM02=0.0 then RAM03:=0;
  140.                        IF Durchlauf = 1 THEN RAM04:=RAM03;
  141.                        IF Durchlauf = 2 THEN RAM05:=RAM03;
  142.                        IF Durchlauf = 3 THEN RAM06:=RAM03;
  143.                        IF Durchlauf = 4 THEN RAM07:=RAM03;
  144.                        IF Durchlauf = 5 THEN RAM08:=RAM03;
  145.                        IF Durchlauf = 6 THEN RAM09:=RAM03;
  146.                        IF Durchlauf = 7 THEN RAM10:=RAM03;
  147.                        IF Durchlauf = 8 THEN RAM11:=RAM03;
  148.                        DezBin01:=RAM01;
  149.                        DezBinUmw1:=0;
  150.                        RAM01:=0;
  151.                        RAM02:=0;
  152.                        RAM03:=0;
  153.                        Durchlauf:=Durchlauf + 1;
  154.                        UNTIL Durchlauf = 9;
  155.                 Writeln;
  156.                 Writeln;
  157.                 Write ('Binäre Zahl=',RAM11:0:0, RAM10:0:0, RAM09:0:0, RAM08:0:0, RAM07:0:0, RAM06:0:0, RAM05:0:0, RAM04:0:0);
  158.                 Writeln;
  159.                 Writeln;
  160.                 Writeln;
  161.                 Write ('Möchten Sie noch einmal eine Dezimal-Binär Umwandlung ');
  162.                 Writeln ('durchführen?');
  163.                 Writeln;
  164.                 Writeln ('J/j oder N/n ?');
  165.                 Writeln;
  166.                 Readln (Frage);
  167.         Clrscr;
  168.         UNTIL Frage IN ['n', 'N'];
  169.         END;
  170.  
  171.  
  172.     2 :     BEGIN
  173.  
  174.         REPEAT
  175.                 
  176.                 Writeln;
  177.             Writeln ('Sie haben die Berechnung "Binär-Dezimal" gewählt');
  178.                 Writeln;
  179.         Write ('Binärzahl');
  180.                 Textcolor (12);
  181.                 Write (' ACHTSTELLIG ');
  182.                 Normvideo;
  183.                 Write ('eingeben !');
  184.                 Writeln;
  185.                 Writeln;
  186.                 Write ('1. Stelle der Binärzahl eingeben: ');
  187.                 Readln (BinDez01);
  188.                 IF BinDez01 > 1 then Writeln ('Binäre Zahl nur 0 oder 1, Resultat ungültig, nochmals ausrechnen !!!');
  189.                 Write ('2. Stelle der Binärzahl eingeben: ');
  190.                 Readln (BinDez02);
  191.                 IF BinDez02 > 1 then Writeln ('Binäre Zahl nur 0 oder 1, Resultat ungültig, nochmals ausrechnen !!!');
  192.                 Write ('3. Stelle der Binärzahl eingeben: ');
  193.                 Readln (BinDez03);
  194.                 IF BinDez03 > 1 then Writeln ('Binäre Zahl nur 0 oder 1, Resultat ungültig, nochmals ausrechnen !!!');
  195.                 Write ('4. Stelle der Binärzahl eingeben: ');
  196.                 Readln (BinDez04);
  197.                 IF BinDez04 > 1 then Writeln ('Binäre Zahl nur 0 oder 1, Resultat ungültig, nochmals ausrechnen !!!');
  198.                 Write ('5. Stelle der Binärzahl eingeben: ');
  199.                 Readln (BinDez05);
  200.                 IF BinDez05 > 1 then Writeln ('Binäre Zahl nur 0 oder 1, Resultat ungültig, nochmals ausrechnen !!!');
  201.                 Write ('6. Stelle der Binärzahl eingeben: ');
  202.                 Readln (BinDez06);
  203.                 IF BinDez06 > 1 then Writeln ('Binäre Zahl nur 0 oder 1, Resultat ungültig, nochmals ausrechnen !!!');
  204.                 Write ('7. Stelle der Binärzahl eingeben: ');
  205.                 Readln (BinDez07);
  206.                 IF BinDez07 > 1 then Writeln ('Binäre Zahl nur 0 oder 1, Resultat ungültig, nochmals ausrechnen !!!');
  207.                 Write ('8. Stelle der Binärzahl eingeben: ');
  208.                 Readln (BinDez08);
  209.                 IF BinDez08 > 1 then Writeln ('Binäre Zahl nur 0 oder 1, Resultat ungültig, nochmals ausrechnen !!!');
  210.                 BinDez01:= (BinDez01) *  128;
  211.                 BinDez02:= (BinDez02) *  64;
  212.                 BinDez03:= (BinDez03) *  32;
  213.                 BinDez04:= (BinDez04) *  16;
  214.                 BinDez05:= (BinDez05) *  8;
  215.                 BinDez06:= (BinDez06) *  4;
  216.                 BinDez07:= (BinDez07) *  2;
  217.                 BinDez08:= (BinDez08) *  1;
  218.                 Writeln;
  219.                 Writeln;
  220.                 Writeln;
  221.                 Writeln;
  222.                 BinDezUmw1:= BinDez04 + BinDez05 + BinDez06 + BinDez07 + BinDez08;
  223.                 Writeln ('Dezimale Zahl=', BinDez01 + BinDez02 + BinDez03 + BinDezUmw1:0:0);
  224.                 Writeln;
  225.                 Writeln;
  226.                 Writeln;
  227.                 BinDez01:= 0 ;
  228.                 BinDez02:= 0 ;
  229.                 BinDez03:= 0 ;
  230.                 BinDez04:= 0 ;
  231.                 BinDez05:= 0 ;
  232.                 BinDez06:= 0 ;
  233.                 BinDez07:= 0 ;
  234.                 BinDez08:= 0 ;
  235.                 BinDezUmw1:=0 ;
  236.                 Write ('Möchten Sie noch einmal eine Binär-Dezimal Umwandlung ');
  237.                 Writeln ('durchführen ?');
  238.                 Writeln;
  239.                 Writeln ('J/j oder N/n ?');
  240.                 Writeln;
  241.                 Readln (Frage);
  242.         Clrscr;
  243.         UNTIL Frage IN ['n', 'N'];
  244.         END;
  245.  
  246.  
  247.     END;
  248.         Clrscr;
  249.         Writeln;
  250.         Writeln;
  251.         Writeln;
  252.         Write ('Möchten Sie noch einmal Berechnungen ');
  253.         Writeln ('durchführen ?');
  254.         Writeln;
  255.         Writeln ('J/j oder N/n ?');
  256.         Writeln;
  257.         Readln (Frage);
  258.         UNTIL Frage IN ['n', 'N'];
  259.  
  260.      Clrscr;
  261.      Writeln;
  262.      Writeln;
  263.      Writeln;
  264.      Writeln ('Vielen Dank, es war schön, mit Ihnen zu arbeiten.');
  265.      Delay (5000) ;
  266. END.
  267.  
  268. END.
  269.